Excel VBA Examples(3)

Microsoft Excel VBA Examples

Sub ListFormulas()
    Dim counter As Integer
    Dim i As Variant
    Dim sourcerange As Range
    Dim destrange As Range
    Set sourcerange = Selection.SpecialCells(xlFormulas)
    Set destrange = Range("M1") '             Substitute your range here
    destrange.CurrentRegion.ClearContents
    destrange.Value = "Address"
    destrange.Offset(0, 1).Value = "Formula"
        If Selection.Count > 1 Then
            For Each i In sourcerange
                counter = counter + 1
                destrange.Offset(counter, 0).Value = i.Address
                destrange.Offset(counter, 1).Value = "'" & i.Formula
            Next
        ElseIf Selection.Count = 1 And Left(Selection.Formula, 1) = "=" Then
                destrange.Offset(1, 0).Value = Selection.Address
                destrange.Offset(1, 1).Value = "'" & Selection.Formula
        Else
                MsgBox "This cell does not contain a formula"
        End If
    destrange.CurrentRegion.EntireColumn.AutoFit
End Sub


Sub AddressFormulasMsgBox()  'Displays the address and formula in message box
    For Each Item In Selection
        If Mid(Item.Formula, 1, 1) = "=" Then
            MsgBox "The formula in " & Item.Address(rowAbsolute:=False, _
                columnAbsolute:=False) & " is:  " & Item.Formula, vbInformation
        End If
    Next
End Sub

Back

Sub DeleteRangeNames()
Dim rName As Name
	For Each rName In ActiveWorkbook.Names
		rName.Delete
	Next rName
End Sub

Back

Sub TypeSheet()
MsgBox "This sheet is a " & TypeName(ActiveSheet)
End Sub

Back

Sub AddSheetWithNameCheckIfExists()
Dim ws As Worksheet
Dim newSheetName As String
newSheetName = Sheets(1).Range("A1")   '   Substitute your range here
    For Each ws In Worksheets
        If ws.Name = newSheetName Or newSheetName = "" Or IsNumeric(newSheetName) Then
            MsgBox "Sheet already exists or name is invalid", vbInformation
            Exit Sub
        End If
    Next
Sheets.Add Type:="Worksheet"
    With ActiveSheet
        .Move after:=Worksheets(Worksheets.Count)
        .Name = newSheetName
    End With
End Sub


Sub Add_Sheet()
Dim wSht As Worksheet
Dim shtName As String
shtName = Format(Now, "mmmm_yyyy")
For Each wSht In Worksheets
    If wSht.Name = shtName Then
        MsgBox "Sheet already exists...Make necessary " & _
            "corrections and try again."
        Exit Sub
    End If
Next wSht
    Sheets.Add.Name = shtName
    Sheets(shtName).Move After:=Sheets(Sheets.Count)
    Sheets("Sheet1").Range("A1:A5").Copy _
        Sheets(shtName).Range("A1")
End Sub


Sub Copy_Sheet()
Dim wSht As Worksheet
Dim shtName As String
shtName = "NewSheet"
For Each wSht In Worksheets
    If wSht.Name = shtName Then
        MsgBox "Sheet already exists...Make necessary " & _
            "corrections and try again."
        Exit Sub
    End If
Next wSht
Sheets(1).Copy before:=Sheets(1)
Sheets(1).Name = shtName
Sheets(shtName).Move After:=Sheets(Sheets.Count)

End Sub

Back

Sub ResetValuesToZero2()
For Each n In Worksheets("Sheet1").Range("WorkArea1")    '   Substitute your information here
    If n.Value <> 0 Then
        n.Value = 0
    End If
Next n
End Sub


Sub ResetTest1()
For Each n In Range("B1:G13")     '   Substitute your range here
    If n.Value <> 0 Then
        n.Value = 0
    End If
Next n
End Sub


Sub ResetTest2()
For Each n In Range("A16:G28")        '   Substitute your range here
    If IsNumeric(n) Then
        n.Value = 0
    End If
Next n
End Sub


Sub ResetTest3()
For Each amount In Range("I1:I13")   '   Substitute your range here
    If amount.Value <> 0 Then
        amount.Value = 0
    End If
Next amount
End Sub


Sub ResetTest4()
For Each n In ActiveSheet.UsedRange
    If n.Value <> 0 Then
        n.Value = 0
    End If
Next n
End Sub


Sub ResetValues()
    On Error GoTo ErrorHandler
    For Each n In ActiveSheet.UsedRange
        If n.Value <> 0 Then
            n.Value = 0
        End If
TypeMismatch:
    Next n
ErrorHandler:
    If Err = 13 Then        'Type Mismatch
        Resume TypeMismatch
    End If
End Sub


Sub ResetValues2()
For i = 1 To Worksheets.Count
On Error GoTo ErrorHandler
    For Each n In Worksheets(i).UsedRange
        If IsNumeric(n) Then
            If n.Value <> 0 Then
                 n.Value = 0
ProtectedCell:
            End If
        End If
    Next n
ErrorHandler:
    If Err = 1005 Then
         Resume ProtectedCell
    End If
Next i
End Sub

Back

Sub CalcPay()
On Error GoTo HandleError
Dim hours
Dim hourlyPay
Dim payPerWeek
hours = InputBox("Please enter number of hours worked", "Hours Worked")
hourlyPay = InputBox("Please enter hourly pay", "Pay Rate")
payPerWeek = CCur(hours * hourlyPay)
MsgBox "Pay is:   " & Format(payPerWeek, "$##,##0.00"), , "Total Pay"
HandleError:
End Sub

Back

'To print header, control the font and to pull second line of header (the date) from worksheet
Sub Printr()
    ActiveSheet.PageSetup.CenterHeader = "&""Arial,Bold Italic""&14My Report" & Chr(13) _
        & Sheets(1).Range("A1")
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
End Sub


Sub PrintRpt1()   'To control orientation
    Sheets(1).PageSetup.Orientation = xlLandscape
    Range("Report").PrintOut Copies:=1
End Sub


Sub PrintRpt2()   'To print several ranges on the same sheet - 1 copy
    Range("HVIII_3A2").PrintOut
    Range("BVIII_3").PrintOut
    Range("BVIII_4A").PrintOut
    Range("HVIII_4A2").PrintOut
    Range("BVIII_5A").PrintOut
    Range("BVIII_5B2").PrintOut
    Range("HVIII_5A2").PrintOut
    Range("HVIII_5B2").PrintOut
End Sub


'To print a defined area, center horizontally, with 2 rows as titles,
'in portrait orientation and fitted to page wide and tall - 1 copy
Sub PrintRpt3()                          
    With Worksheets("Sheet1").PageSetup  
        .CenterHorizontally = True
        .PrintArea = "$A$3:$F$15"
        .PrintTitleRows = ("$A$1:$A$2")
        .Orientation = xlPortrait
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With
    Worksheets("Sheet1").PrintOut
End Sub

Back

' This is a simple example of using the OnEntry property.  The Auto_Open sub calls the Action
' sub.  The font is set to bold in the ActiveCell if the value is >= 500.  Thus if the value is >=500,
' then ActiveCell.Font.Bold = True.  If the value is less than 500, then ActiveCell.Font.Bold = False.
' The Auto_Close sub "turns off" OnEntry.

Sub Auto_Open()
ActiveSheet.OnEntry = "Action"
End Sub

Sub Action()
If IsNumeric(ActiveCell) Then
    ActiveCell.Font.Bold = ActiveCell.Value >= 500
End If
End Sub


Sub Auto_Close()
ActiveSheet.OnEntry = ""
End Sub

Back

'These subs place the value (result) of a formula into a cell rather than the formula.

Sub GetSum()                    ' using the shortcut approach
[A1].Value = Application.Sum([E1:E15])
End Sub

Sub EnterChoice()
Dim DBoxPick As Integer
Dim InputRng As Range
Dim cel As Range
DBoxPick = DialogSheets(1).ListBoxes(1).Value
Set InputRng = Columns(1).Rows

For Each cel In InputRng
    If cel.Value = "" Then
        cel.Value = Application.Index([InputData!StateList], DBoxPick, 1)
        End
    End If
Next

End Sub

Back

' To add a range name for known range
Sub AddName1()
ActiveSheet.Names.Add Name:="MyRange1", RefersTo:="=$A$1:$B$10"
End Sub


' To add a range name based on a selection
Sub AddName2()
ActiveSheet.Names.Add Name:="MyRange2", RefersTo:="=" & Selection.Address()
End Sub


' To add a range name based on a selection using a variable. Note: This is a shorter version
Sub AddName3()
Dim rngSelect As String
rngSelect = Selection.Address
ActiveSheet.Names.Add Name:="MyRange3", RefersTo:="=" & rngSelect
End Sub


' To add a range name based on a selection. (The shortest version)
Sub AddName4()
Selection.Name = "MyRange4"
End Sub

Back

Microsoft Excel VBA Examples